HPAVC/HPAVC CD-ROM.iso/pc/2924.ZIP/DMLXREF.ARC/GEN.IMP

Text File | 1988-12-22 | 24.2 KB | 875 lines

(**************************************************************************)
(*                                                                        *)
(*          1)   System programming extensions                            *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

PROCEDURE Abend(ExitCode : BYTE;
                ProcAddr : POINTER);

VAR
  CallerOfs : WORD;
  CallerSeg : WORD;

CONST
  Hex : ARRAY[0..15] OF CHAR = '0123456789ABCDEF';

  FUNCTION W2H(Num : WORD) : STRING;
  BEGIN
    W2H := Hex[HI(Num) SHR 4] + Hex[HI(Num) AND $0F] +
           Hex[LO(Num) SHR 4] + Hex[LO(Num) AND $0F];
  END;

BEGIN
  IF ProcAddr <> NIL THEN BEGIN
    CallerOfs := OFS(ProcAddr^);
    CallerSeg := SEG(ProcAddr^)-PrefixSeg-16;
    END
  ELSE BEGIN
    INLINE($8B/$46/$02);            { MOV AX,[BP+2] }
    INLINE($36/$89/$46/<CallerOfs); { MOV SS:[BP-OFS(CallerOfs)],AX }
    INLINE($8B/$46/$04);            { MOV AX,[BP+4] }
    INLINE($36/$89/$46/<CallerSeg); { MOV SS:[BP-OFS(CallerSeg)],AX }
    CallerSeg := CallerSeg-PrefixSeg-16;
    CallerOfs := CallerOfs - 4;
    END;
  TEXTMODE(LastMode);
  WRITELN(^G^J^M,'User Abend Number: ',ExitCode,' Addr: ',W2H(CallerSeg),':',W2H(CallerOfs));
  HALT(ExitCode);
END;

VAR
  ProcAddr_G : POINTER;

PROCEDURE CallProc;
  INLINE($FF/$1E/ProcAddr_G);   { CALL FAR [ProcAddr_G] -> An indirect FAR Call }

PROCEDURE CallProcedure(ProcAddr : POINTER);
BEGIN
  ProcAddr_G := ProcAddr;
  CallProc;
END;

PROCEDURE CallProcX(I1 : INTEGER; VAR S1 : STRING; VAR I2 : INTEGER);
  INLINE($FF/$1E/ProcAddr_G);   { CALL FAR [ProcAddr_G] -> An indirect FAR Call }

PROCEDURE CallProcedureX(ProcAddr : POINTER; I1 : INTEGER; VAR S1 : STRING; VAR I2 : INTEGER);
BEGIN
  ProcAddr_G := ProcAddr;
  CallProcX(I1,S1,I2);
END;

FUNCTION LongAddr(Seg, Ofs : WORD) : LONGINT;

BEGIN
  LongAddr := LONGINT(Seg) * 16 + Ofs;
END;

FUNCTION Same (VAR Var1, Var2; Len : WORD) : BOOLEAN;
VAR
  Ptr1,
  Ptr2 : ^BYTE;
  Ctr  : INTEGER;
  Test : BOOLEAN;

BEGIN
  Len  := PRED(Len); {Since our counter starts from zero, and Len starts at one}
  Ptr1 := ADDR(Var1);
  Ptr2 := ADDR(Var2);

  Ctr := 0;
  REPEAT
    Test := (Ptr1^ = Ptr2^);
    Ctr := SUCC(Ctr);
    Ptr1 := PTR(SEG(Ptr1^),SUCC(OFS(Ptr1^)));
    Ptr2 := PTR(SEG(Ptr2^),SUCC(OFS(Ptr2^)));
    UNTIL (NOT Test) OR (Ctr > Len);

  Same := Test;
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          2)   File Protection                                          *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION ReadOnlyGetAttr(FileName : STRING) : BOOLEAN;
VAR
  Name      : ARRAY[1..64] OF CHAR;
  DosReg    : REGISTERS;

BEGIN
  S2Z(FileName,Name);
  WITH DosReg DO BEGIN
    DS := SEG(Name);
    DX := OFS(Name);
    AL := $00;    { Get Attributes }
    AH := $43;
    INTR(_DOS,DosReg);
    IF (Flags AND $0001) = 1  { Error }
      THEN ReadOnlyGetAttr := FALSE
      ELSE ReadOnlyGetAttr := ((CL AND $01) = $01);
    END;
END;

FUNCTION ReadOnlySetAttr(FileName : STRING ; Flag : BOOLEAN) : INTEGER;

VAR
  Name      : ARRAY[1..64] OF CHAR;
  DosReg    : REGISTERS;

BEGIN
  S2Z(FileName,Name);
  WITH DosReg DO BEGIN
    DS := SEG(Name);
    DX := OFS(Name);
    AL := $00;    { Get Attributes }
    AH := $43;
    INTR(_DOS,DosReg);
    IF (Flags AND $0001) = 1    { Error }
      THEN ReadOnlySetAttr := AX
      ELSE BEGIN
        IF Flag
          THEN CL := CL OR  $01   { Set/Reset Read Only Bit }
          ELSE CL := CL AND $FE;
        DS := SEG(Name);
        DX := OFS(Name);
        AL := $01;    { Set Attributes }
        AH := $43;
        INTR(_DOS,DosReg);
        IF (Flags AND $0001) = 1    { Error }
          THEN ReadOnlySetAttr := AX
          ELSE ReadOnlySetAttr := 0;
        END;
    END;
END;

FUNCTION ReadOnlyExist(FileName : STRING) : BOOLEAN;
VAR
  AnyFDummy : FILE;
  AnyF      : FILEREC ABSOLUTE AnyFDummy;
  DosReg    : REGISTERS;
  AXStr     : STRING;

BEGIN
  ASSIGN(AnyFDummy,FileName);
  WITH DosReg DO BEGIN
    DS := SEG(AnyF.Name);
    DX := OFS(AnyF.Name);
    AL := $00;  { Read Only Access }
    AH := $3D;
    INTR(_DOS,DosReg);           { Open File }
    IF (Flags AND $0001) = 1    { Error }
      THEN BEGIN
        IF AX <> 2 THEN BEGIN
          STR(AX:5,AXStr);
          ScrErrMsg(FileName + ' can''t be opened, DOS error: '+ AXStr);
          END;
        ReadOnlyExist := FALSE;
        END
      ELSE WITH AnyF DO BEGIN
        ReadOnlyExist := TRUE;
        BX := AX;
        AH := $3E;
        INTR(_DOS,DosReg);           { Close File }
        END;
    END;
END;

FUNCTION FileOpen(VAR GenFileDummy;
                      GenFileRecLen   : WORD;
                      GenFileOpenMode : WORD) : INTEGER;
VAR
  GenF   : FILEREC ABSOLUTE GenFileDummy;
  GenTF  : TEXTREC ABSOLUTE GenFileDummy;
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    DS := SEG(GenF.Name);
    DX := OFS(GenF.Name);
    AL := GenFileOpenMode;  { $00 = Read Only , $01 = Write Only, $02 = Read/Write Access }
    AH := $3D;
    INTR(_DOS,DosReg);           { Open File }
    IF (Flags AND $0001) = 1     { Error }
      THEN FileOpen := AX
      ELSE WITH GenF DO BEGIN
        FileOpen := 0;
        Mode := FMInOut;  (*** T4 ***)
        Handle := AX;
        IF GenFileRecLen = 0 THEN WITH GenTF DO BEGIN  { Text File }
          (* ??? Various Pointers ??? *)
          ScrErrMsg('Read Only Processing Of Text Files Supported Directly by RESET');
          Abend($FF,NIL);
          Mode     := FMInput;
          BufSize  := 128;
          BufPos   := 0;
          BufEnd   := 0;
          END
         ELSE RecSize := GenFileRecLen;
        END;
    END;
END;

FUNCTION FileAssignAndOpen (    GenFileName      : STRING;
                            VAR GenFileDummy;
                                GenFileRecLen    : WORD;
                                GenFileOpenMode  : WORD) : BOOLEAN;

VAR
  GenFile : FILE ABSOLUTE GenFileDummy;

BEGIN
  ASSIGN(GenFile,GenFileName);
  FileAssignAndOpen := FileOpen(GenFile,GenFileRecLen,GenFileOpenMode) = 0
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          3)   Text Encryption                                          *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION EnCrypt (Orig : STRING) : STRING;

VAR
  Ctr : INTEGER;
  Len : INTEGER;

BEGIN
  Len := LENGTH(Orig);
  FOR Ctr := 1 TO Len DO BEGIN
    IF Odd(Ctr)
      THEN Orig[Ctr] := CHR(ORD(Orig[Ctr]) + (Len-Ctr+1))
      ELSE Orig[Ctr] := CHR(ORD(Orig[Ctr]) - (Len-Ctr+1));
    IF NOT (Orig[Ctr] IN ['!'..'~']) THEN BEGIN
        EnCrypt := '';
        EXIT;
        END;
    END;
  EnCrypt := Orig;
END;

FUNCTION DeCrypt (Orig : STRING) : STRING;

VAR
  Ctr : INTEGER;
  Len : INTEGER;

BEGIN
  Len := LENGTH(Orig);
  FOR Ctr := 1 TO LENGTH(Orig) DO
    IF Odd(Ctr)
      THEN Orig[Ctr] := CHR(ORD(Orig[Ctr]) - (Len-Ctr+1))
      ELSE Orig[Ctr] := CHR(ORD(Orig[Ctr]) + (Len-Ctr+1));
  DeCrypt := Orig;
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          4)   General Purpose Video                                    *)
(*                                                                        *)
(**************************************************************************)

PROCEDURE GenBeep (Frequency, Duration : WORD);
BEGIN
  IF Frequency < 25 THEN Frequency := 460;
  IF Duration  < 5  THEN Duration  := 30;
  SOUND (Frequency);
  DELAY (Duration);
  NOSOUND;
  DELAY (10);  {Allow the sound to stop before leaving this procedure}
END;

FUNCTION ColorMonitorInstalled : BOOLEAN;
(* This will NOT work for Hercules card unless GrafBase is $B000 *)
CONST
  GrafBase = $B800;

VAR
  I      : INTEGER;
  DosReg : REGISTERS;

BEGIN
  INTR ($11,DosReg);
  I := MEMW [GrafBase:0000];
  MEMW [GrafBase:0000] := NOT I;
  ColorMonitorInstalled :=
    (I = NOT MEMW [GrafBase:0000]) AND (DosReg.AX AND $30 <> $30);
  MEMW [GrafBase:0000] := I;
END;

PROCEDURE Cursor (Visible : BOOLEAN);
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN                  { First return the scan lines.   }
    AX := $0300;                        { BIOS VIDEO subfunction 3       }
    BX := $0000;                        { Only works for display page 0  }
    INTR (_VIDEO, DosReg);
    IF NOT Visible THEN                 { Turn cursor off by setting     }
      CX := CX OR $3000                 { bits 5 and 6 of CH, and        }
    ELSE                                { turn curson on by clearing the }
      CX := CX AND $CFFF;               { bits.                          }
    AX := $0100;                        { Write the scan lines back out. }
    INTR (_VIDEO, DosReg)
    END;
END;

PROCEDURE CursorInsertSize;
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    AX := $0300;
    BX := $0000;
    INTR (_VIDEO, DosReg);

    IF CL = 7 THEN CH := (CH AND $30) OR $04
              ELSE CH := (CH AND $30) OR $0A;
    AX := $0100;
    INTR (_VIDEO, DosReg);
    END;
END;

PROCEDURE CursorOverwriteSize;
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    AX := $0300;
    BX := $0000;
    INTR (_VIDEO, DosReg);

    IF CL = 7 THEN CH := (CH AND $30) OR $06
              ELSE CH := (CH AND $30) OR $0C;
    AX := $0100;
    INTR (_VIDEO, DosReg);
    END;
END;

FUNCTION ScrForeCursorColor : WORD;
VAR
   Reg : REGISTERS;

BEGIN
   Reg.AH := $08;
   Reg.BH := $00;
   INTR ($10, Reg);
   ScrForeCursorColor := (Reg.AH AND $0F);
END;

FUNCTION ScrBackCursorColor : WORD;
VAR
   Reg : REGISTERS;

BEGIN
   Reg.AH := $08;
   Reg.BH := $00;
   INTR ($10, Reg);
   ScrBackCursorColor := ((Reg.AH AND $70) SHR 4);
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          5)   Video Messages                                           *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

PROCEDURE Wait (DispWait : BOOLEAN);
TYPE
  T_Wait = ARRAY [1..4] OF WORD;

CONST

  WaitOn        : BOOLEAN = FALSE;
  WaitMsg       : T_Wait = ($8257, $8241, $8249, $8254);  { WAIT green on black }
  SaveColorWait : T_Wait = (0,0,0,0);
  SaveMonoWait  : T_Wait = (0,0,0,0);

VAR
  ColorWait     : T_Wait ABSOLUTE $B800:$0F98;
  MonoWait      : T_Wait ABSOLUTE $B000:$0F98;

BEGIN
  IF (DispWait) AND (NOT WaitOn) THEN BEGIN
    SaveColorWait := ColorWait;
    SaveMonoWait  := MonoWait;
    ColorWait     := WaitMsg;
    MonoWait      := WaitMsg;
    WaitOn        := TRUE;
    END
  ELSE IF (NOT DispWait) AND (WaitOn) THEN BEGIN
    WaitOn    := FALSE;
    ColorWait := SaveColorWait;
    MonoWait  := SaveMonoWait;
    END;
END;

PROCEDURE Pause;
VAR
  SaveColorDot : INTEGER;
  SaveMonoDot  : INTEGER;
  ColorScrDot  : WORD ABSOLUTE $B800:$0F00;
  MonoScrDot   : WORD ABSOLUTE $B000:$0F00;
  CH           : CHAR;

BEGIN
  SaveColorDot := ColorScrDot;
  SaveMonoDot  := MonoScrDot;

  ColorScrDot := $8F1D; {Display a nice character to flash on the screen}
  MonoScrDot  := $8F1D;
  REPEAT
    UNTIL KEYPRESSED;
  CH := READKEY;

  ColorScrDot := SaveColorDot;
  MonoScrDot  := SaveMonoDot;
END;

PROCEDURE ScrStatMsg (Message : STRING);
VAR
   X, Y, Color : INTEGER;
   BackColor   : INTEGER;

BEGIN
  Color := ScrForeCursorColor;
  BackColor := ScrBackCursorColor;
  IF Message <> '' THEN BEGIN
    IF NOT ColorMonitorInstalled
      THEN TEXTCOLOR(D_ForeColor)
      ELSE TEXTCOLOR(D_StatColor);
    TEXTBACKGROUND(D_SurroundColor);
    END;
  X := WhereX;
  Y := WhereY;
  GOTOXY (1,25);
  WRITE(LJS(Message,76));
  TEXTCOLOR(Color);
  TEXTBACKGROUND(BackColor);
  GOTOXY(X,Y);
END;

PROCEDURE ScrErrMsg (Message : STRING );

VAR
   X, Y, Color : INTEGER;
   BackColor   : INTEGER;
   Ctr         : INTEGER;

BEGIN
  Color := ScrForeCursorColor;
  BackColor := ScrBackCursorColor;
  IF NOT ColorMonitorInstalled
    THEN TEXTCOLOR(D_ForeColor)
    ELSE TEXTCOLOR(D_ErrColor);
  TEXTBACKGROUND(D_SurroundColor);
  X := WhereX;
  Y := WhereY;
  GOTOXY (1,25);
  Message := LJS(Message,64);
  Message := Message + ' Press '+#17#217+'   ';
  WRITE(Message);
  IF NOT KbdScrollLockStatus THEN GenBeep (0,0);
  REPEAT
    UNTIL KbdInputValue = K_Enter;
  GOTOXY (1,25);
  TEXTCOLOR(Color);
  TEXTBACKGROUND(BackColor);
  Message := LJS(' ',76);
  WRITE(Message);    { Remove message from screen }
  GOTOXY(X,Y);
END;

FUNCTION ScrYouAreSure (Message : STRING ) : BOOLEAN;
BEGIN
  IF Message = '' THEN Message := 'CONTINUE';
  Message := Message + ',';
  Message := LJS(Message,36);
  ScrStatMsg ('Hit any key to '+Message+'  or hit <ESC> to CANCEL.');
  IF KbdInputValue = K_Esc THEN ScrYouAreSure := FALSE
                           ELSE ScrYouAreSure := TRUE;
  ScrStatMsg('');
END;

FUNCTION ScrYN (Message : STRING) : BOOLEAN;
VAR
  X,Y,Color : INTEGER;
  BackColor : INTEGER;

BEGIN
  IF Message = '' THEN Message := 'Are You Sure';
  Message := LJS(Message,66);
  X := WHEREX;
  Y := WHEREY;
  Color := ScrForeCursorColor;
  BackColor := ScrBackCursorColor;
  ScrStatMsg(Message + ' (Y/N)? ');
  IF NOT ColorMonitorInstalled
    THEN TEXTCOLOR(D_ForeColor)
    ELSE TEXTCOLOR(D_StatColor);
  TEXTBACKGROUND(D_SurroundColor);
  GOTOXY(76,25);
  REPEAT
    UNTIL CHR(KbdInputValue) IN ['Y', 'y', 'N', 'n'];
  WRITE (KbdLastChar);
  CASE KbdLastChar OF
    'Y', 'y' : ScrYN := TRUE;
    'N', 'n' : ScrYN := FALSE;
    END; {CASE}
  GOTOXY (X,Y);
  TEXTCOLOR(Color);
  TEXTBACKGROUND(BackColor);
  ScrStatmsg('');
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          6)   Disk and Memory Sizes                                    *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION BytesOnDiskFree(Drive : CHAR) : LONGINT;
VAR
  DosReg    : REGISTERS;

BEGIN
  Drive := UPCASE(Drive);
  IF NOT (Drive IN [' ','A'..'Z']) THEN BEGIN
    BytesOnDiskFree := -1;
    EXIT;
    END;
  WITH DosReg DO BEGIN
    IF Drive = ' '
      THEN DL := 0
      ELSE DL := ORD(Drive) - ORD('@');
    AH := $36;
    INTR(_DOS,DosReg);
    IF AX = $FFFF
      THEN BytesOnDiskFree := -1
      ELSE BytesOnDiskFree := LONGINT(CX) * AX * BX;
    END;
END;

FUNCTION FreeDOSMem : LONGINT;
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    AH := $48;
    BX := $FFFF;
    INTR($21,DosReg);
    FreeDOSMem := LONGINT(BX) * 16;
    END;
END;

FUNCTION SizeOfMem : LONGINT;
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    INTR ($12, DosReg);
    SizeOFMem := LONGINT(AX) * 1024;
    END;
END;

FUNCTION StackAvail : WORD;

VAR
  SOfs : WORD;

BEGIN
(*                           { OVERKILL BUT 'Neat' }
  INLINE($36/$89/$66/<SOfs); { MOV SS:SOfs,SP --> MOV SS:[BP-OFS(SOfs),SP],SP }
  StackAvail := SOfs+2;
*)
  StackAvail := OFS(SOfs)+2;
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          7)   Instruction Timing                                       *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION TimeElapsed : REAL;

VAR
  Reg : REGISTERS;

BEGIN
  Reg.AH := $2C;
  INTR($21,Reg);
  WITH Reg DO
    TimeElapsed :=  CH*3600.0 + CL*60.0 + DH + DL/100.0;
END;

FUNCTION TimeTotal(Start , Stop : REAL) : STRING;

BEGIN
  TimeTotal := Strip(R2S((Stop - Start),'###,###@.@#'),S_Leading);
END;


{.PA}

(**************************************************************************)
(*                                                                        *)
(*          8)   General Purpose File                                     *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION Exist (FileName: STRING) : BOOLEAN;
VAR
   Fil : FILE;
BEGIN
   ASSIGN (Fil, FileName);
   (*$I-*)
   RESET (Fil);
   (*$I+*)
   IF (IORESULT = 0) THEN BEGIN
      CLOSE (Fil);
      Exist := TRUE;
      END
   ELSE Exist := FALSE;
END;

FUNCTION LinesInFile (FileName : STRING) : INTEGER;
VAR
  Ctr      : INTEGER;
  TempFile : TEXT;

BEGIN
  IF ReadOnlyExist (FileName) THEN BEGIN
    ASSIGN (TempFile, FileName);
    RESET  (TempFile);
    Ctr := 0;
    WHILE NOT EOF (TempFile) DO BEGIN
      Ctr := SUCC (Ctr);
      READLN (TempFile);
      END;
    LinesInFile := Ctr;
    CLOSE (TempFile);
    END
  ELSE
    LinesInFile := -1;
END;

FUNCTION GetFileDateAndTimeString (FileName : STRING) : STRING;
VAR
   Day, Month, Year,
   Hour, Minute, Second : INTEGER;
   AmPm                 : STRING[3];
   DosReg               : REGISTERS;

BEGIN
   FileName := FileName + #0;
   WITH DosReg DO BEGIN
      DS := SSeg;                { FileName is a Stack variable }
      DX := OFS (FileName) + 1;  { ASCIIZ String }
      AX := $3D00;               { Open a File }
      INTR (_DOS, DosReg);
      IF (FLAGS AND $0001) = 1 THEN BEGIN
         GetFileDateAndTimeString := 'FileError # '+ I2S(AX,'###')+' on '+FileName;
         EXIT;
         END;
      BX := AX;
      AX := $5700;               { Get date and time }
      INTR (_DOS, DosReg);
      Month  := (DX SHR 5)  AND $000F;
      Day    :=  DX         AND $001F;
      Year   := (DX SHR 9)  AND $007F + 1980;
      Hour   := (CX SHR 11) AND $001F;
      Minute := (CX SHR 5)  AND $003F;
      Second :=  CX         AND $001F * 2;
      IF Hour >= 12 THEN
         AmPm := ' pm'
      ELSE
         AmPm := ' am';
      IF Hour > 12 THEN
         Hour := Hour - 12;
      GetFileDateAndTimeString
                         := I2S (Month, '@@')   + '/' +
                            I2S (Day,   '@@')   + '/' +
                            I2S (Year,  '@@@@') + ' ' +
                            I2S (Hour,  '@@')   + ':' +
                            I2S (Minute, '@@')  + AmPm;
      AX := $3E00;    { Close File }
      INTR (_DOS, DosReg);
      END;
END;

FUNCTION GetFileDateAndTimeLongInt (FileName : STRING) : LONGINT;
VAR
  DosReg : REGISTERS;

BEGIN
   FileName := FileName + #0;
   WITH DosReg DO BEGIN
      DS := SSEG;                { FileName is a Stack variable }
      DX := OFS (FileName) + 1;  { ASCIIZ String }
      AX := $3D00;               { Open a File }
      INTR (_DOS, DosReg);
      IF (FLAGS AND $0001) = 1 THEN BEGIN
         GetFileDateAndTimeLongInt := -1;
         EXIT;
         END;
      BX := AX;
      AX := $5700;               { Get date and time }
      INTR (_DOS, DosReg);
      GetFileDateAndTimeLongInt := LONGINT(DX) SHL 16 + CX;
      AX := $3E00;    { Close File }
      INTR (_DOS, DosReg);
      END;
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          9)   Math                                                     *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION Power (X, Y : REAL) : REAL;
BEGIN
   Power := EXP (Y * LN (X));
END;

FUNCTION Log (x : REAL) : REAL;
BEGIN
   Log := (Ln (x)/ Ln (10));
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          10)  DOS and Environment                                      *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

FUNCTION DOSVersionR : REAL;
VAR
  DosReg : REGISTERS;

BEGIN
  WITH DosReg DO BEGIN
    AH := $30;
    INTR (_DOS, DosReg);
    IF AL = 0 THEN DOSVersionR := 1.1 {All the info we can get for DOS 1.x}
              ELSE DOSVersionR := AL + (AH / 100.0);
    END;
END;

FUNCTION WhoAmI : STRING;
VAR
  E : INTEGER;   { environment segment }
  I : INTEGER;   { offset within segment }
  T : STRING;    { Temp Program name }

BEGIN
  WhoAmI := '';
  T      := '';
  IF DosVersion < 3.0 THEN EXIT;
  E := MEMW[PREFIXSEG:$2C];          { get environment segment }
  I := 0;                            { start at the beginning  }
  REPEAT
    WHILE MEM[E:I] <> 0 DO           { search a zero byte }
      I := I+1;
    I := I+1;
    UNTIL MEM[E:I] = 0;              { stop at second zero byte }
  I := I+3;                          { skip to loaded file name }
  WHILE (MEM[E:I] <> 0) DO BEGIN     { display the load descriptor }
    T := T + (CHR(MEM[E:I]));
    I := I+1;
    END;
  WhoAmI := T;
END;

FUNCTION GetEnvString(EnvVar : STRING) : STRING;
VAR
  E    : INTEGER;   { environment segment }
  I    : INTEGER;   { offset within segment }
  T    : STRING;    { environment value }
  Sep  : INTEGER;   { position of = }
  Pre  : STRING;    { value before = }
  Post : STRING;    { value after = }
  Done : BOOLEAN;   { found variable in question }

BEGIN
  EnvVar := Strip(StrCase(EnvVar,S_ToUpper),S_AllSpaces);
  IF EnvVar = '' THEN BEGIN
    GetEnvString := '';       { why bother searching for nothing }
    EXIT;
    END;
  IF EnvVar[LENGTH(EnvVar)] = '=' THEN EnvVar := COPY(EnvVar,1,LENGTH(EnvVar)-1);
  GetEnvString := '';
  E := MEMW[PREFIXSEG:$2C];          { get environment segment }
  I := 0;                            { start at the beginning  }
  Done := FALSE;
  REPEAT
    T := '';
    WHILE MEM[E:I] <> 0 DO BEGIN     { search a zero byte }
      T := T + (CHR(MEM[E:I]));
      I := I+1;
      END;
    Sep := POS('=',T);
    IF Sep <> 0 THEN BEGIN
      Pre  := Strip(StrCase(COPY(T,1,Sep-1)        ,S_ToUpper),S_AllSpaces);
      Post := Strip(StrCase(COPY(T,Sep+1,LENGTH(T)),S_ToUpper),S_Leading+S_Trailing);
      IF Pre = EnvVar THEN Done := TRUE;
      END;
    I := I+1;
    UNTIL (MEM[E:I] = 0) OR Done;    { stop at second zero byte }
  IF Done
    THEN GetEnvString := Post
    ELSE GetEnvString := '';
END;

FUNCTION GetDMLVersion(Module : WORD) : STRING;
BEGIN
  IF Module > 4 THEN Module := 0;
  GetDMLVersion := R2S(Versions[Module],'##.@@');
END;

FUNCTION GetDMLVersions : STRING;
BEGIN
  GetDMLVersions := 'Unit Versions: ' +
               'DML: '  + GetDMLVersion(0) +
             ', GEN: '  + GetDMLVersion(1) +
             ', NUM: '  + GetDMLVersion(2) +
             ', STRG: ' + GetDMLVersion(3) +
             ', KBD: '  + GetDMLVersion(4);
END;